home *** CD-ROM | disk | FTP | other *** search
/ Fritz: All Fritz / All Fritz.zip / All Fritz / FILES / PROGMISC / XLISP.LZH / XLISPLSP.ARC / PP.LSP < prev    next >
Text File  |  1985-06-24  |  6KB  |  209 lines
  1. ;+
  2. ;               PP 1.0 : (C) Copyright 1985 by Gregory Frascadore
  3. ;
  4. ;   This software may be copied, modified, and distributed to others as long
  5. ;   as it is not sold for profit, and as long as this copyright notice is
  6. ;   retained intact. For further information contact the author at:
  7. ;               frascado%umn-cs.CSNET   (on CSNET)
  8. ;               75106,662               (on CompuServe)
  9. ;-
  10.  
  11. ;+
  12. ;                               PP 1.0
  13. ; DESCRIPTION
  14. ;   PP is a function for producing pretty-printed XLISP code. Version 1.0
  15. ;   works with XLISP 1.4 and may work with other versions of XLISP or other
  16. ;   lisp systems.
  17. ;
  18. ; UPDATE HISTORY
  19. ;   Version 1.0 - Original version, 11 April 1985 by Gregory Frascadore.
  20. ;
  21. ;-
  22.  
  23. ;+
  24. ; pp
  25. ;   This function pretty-prints an s-expression.
  26. ;
  27. ; format
  28. ;   (pp <expr> [<sink>] )
  29. ;
  30. ;       <expr>  the expression to print.
  31. ;       <sink>  optional. the sink to print to. defaults to
  32. ;                   *standard-output*
  33. ;       <maxlen> the threshold that pp uses to determine when an expr
  34. ;                   should be broken into several lines. The smaller the
  35. ;                   value, the more lines are used. Defaults to 45 which
  36. ;                   seems reasonable and works well too.
  37. ;-
  38.  
  39. (let ((pp-stack* nil)
  40.       (pp-istack* nil)
  41.       (pp-currentpos* nil)
  42.       (pp-sink* nil)
  43.       (pp-maxlen* nil))
  44.  
  45. (defun pp (*expr &optional *sink *maxlen)
  46.    (setq pp-stack* nil
  47.          pp-istack* '(0)
  48.          pp-currentpos* 0
  49.          pp-sink* *sink
  50.          pp-maxlen* *maxlen)
  51.  
  52.    (if (null pp-sink*) (setq pp-sink* *standard-output*))
  53.    (if (null pp-maxlen*) (setq pp-maxlen* 45))
  54.  
  55.    (pp-expr *expr)
  56.    (pp-newline)
  57.    t)
  58.  
  59.  
  60. (defun pp-expr (*expr)
  61.    (cond ((consp *expr)
  62.             (pp-list *expr) )
  63.  
  64.          (t (pp-prin1 *expr)) ) )
  65.  
  66.  
  67. ;+
  68. ; pp-list
  69. ;   Pretty-print a list expression.
  70. ;       IF <the flatsize length of *expr is less than pp-maxlen*>
  71. ;           THEN print the expression on one line,
  72. ;       ELSE
  73. ;       IF <the car of the expression is an atom>
  74. ;           THEN print the expression in the following form:
  75. ;                   "(atom <item1>
  76. ;                          <item2>
  77. ;                           ...
  78. ;                          <itemn> )"
  79. ;       ELSE
  80. ;       IF <the car of the expression is a list>
  81. ;           THEN print the expression in the following form:
  82. ;                   "(<list1>
  83. ;                     <item2>
  84. ;                       ...
  85. ;                     <itemn> )"
  86. ;
  87. ;-
  88.  
  89. (defun pp-list (*expr)
  90.    (cond ((< (flatsize *expr) pp-maxlen*)
  91.             (pp-prin1 *expr) )
  92.  
  93.          ((atom (car *expr))
  94.             (pp-start)
  95.             (pp-prin1 (car *expr))
  96.             (pp-princ " ")
  97.             (pp-pushmargin)
  98.             (pp-rest (cdr *expr))
  99.             (pp-popmargin)
  100.             (pp-finish) )
  101.  
  102.          (t (pp-start)
  103.             (pp-pushmargin)
  104.             (pp-rest *expr)
  105.             (pp-popmargin)
  106.             (pp-finish) ) ) )
  107.  
  108. ;+
  109. ; pp-rest
  110. ;   pp-expr each element of a list and do a pp-newline after every call to
  111. ;   pp-expr except the last.
  112. ;-
  113.  
  114. (defun pp-rest (*rest)
  115.    (do* ((item* *rest (cdr item*)))
  116.         ((null item*))
  117.             (pp-expr (car item*))
  118.             (if (not (null (cdr item*))) (pp-newline)) ) )
  119.  
  120. ;+
  121. ; pp-newline
  122. ;   Print out a newline character and indent to the current margin setting
  123. ;   which is maintained at the top of the pp-istack. Note that is the
  124. ;   current top of the pp-stack* is a ")" we push a " " so that we will know
  125. ;   to print a space before closing any parenthesis which were started on a
  126. ;   different line from the one they are being closed on.
  127. ;-
  128.  
  129. (defun pp-newline ()
  130.    (if (eql ")" (pp-top pp-stack*)) (pp-push " " pp-stack*))
  131.  
  132.    (terpri pp-sink*)
  133.    (spaces (pp-top pp-istack*) pp-sink*)
  134.    (setq pp-currentpos* (pp-top pp-istack*)) )
  135.  
  136. ;+
  137. ; pp-finish
  138. ;   Print out the closing ")". If the top of the pp-stack* has a " " on it,
  139. ;   then print out the space, then the ")" , and then pop both off the stack.
  140. ;-
  141.  
  142. (defun pp-finish ()
  143.    (cond ((eql ")" (pp-top pp-stack*))
  144.             (pp-princ ")") )
  145.  
  146.          (t
  147.             (pp-princ " )")
  148.             (pp-pop pp-stack*) ) )
  149.  
  150.    (pp-pop pp-stack*) )
  151.  
  152.  
  153. ;+
  154. ; pp-start
  155. ;   Start printing a list. ie print the "(" and push a ")" on the pp-stack*
  156. ;   so that pp-finish knows to print a ")" when closing an list.
  157. ;-
  158.  
  159. (defun pp-start ()
  160.    (pp-princ "(")
  161.    (pp-push ")" pp-stack*) )
  162.  
  163. ;+
  164. ; pp-princ
  165. ;   Prints out an expr without any quotes and updates the pp-currentpos*
  166. ;   pointer so that we know where on the line the cursor is at.
  167. ;-
  168.  
  169. (defun pp-princ (*expr)
  170.     (setq pp-currentpos* (+ pp-currentpos* (flatc *expr)))
  171.     (princ *expr pp-sink*) )
  172.  
  173. ;+
  174. ; pp-prin1
  175. ;   Does the same thing as pp-prin1, except that the expr is printed with
  176. ;   quotes if needed. Hence pp-prin1 uses flatsize to calc expr length instead
  177. ;   of flatc.
  178. ;-
  179.  
  180. (defun pp-prin1 (*expr)
  181.     (setq pp-currentpos* (+ pp-currentpos* (flatsize *expr)))
  182.     (prin1 *expr pp-sink*) )
  183.  
  184. (defmacro pp-push (*item *stack)
  185.    `(setq ,*stack (cons ,*item ,*stack)) )
  186.  
  187.  
  188. (defmacro pp-pop (*stack)
  189.    `(let ((top* (car ,*stack)))
  190.  
  191.         (setq ,*stack (cdr ,*stack))
  192.         top*) )
  193.  
  194.  
  195. (defun pp-top (*stack) (car *stack))
  196.  
  197.  
  198. (defun pp-pushmargin ()
  199.    (pp-push pp-currentpos* pp-istack*) )
  200.  
  201.  
  202. (defun pp-popmargin ()
  203.    (pp-pop pp-istack*) )
  204.  
  205. (defun spaces (n f)
  206.     (dotimes (x n) (write-char 32 f)))
  207.  
  208. )
  209.